home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / itcl1_31.z / itcl1_31 / tcldev / itcl-1.3 / tests / testlib.tcl < prev    next >
Encoding:
Text File  |  1993-09-23  |  4.1 KB  |  128 lines
  1. #
  2. # Test support routines (adapted from Ousterhout's Tcl set)
  3. # ----------------------------------------------------------------------
  4. #   AUTHOR:  Michael J. McLennan       Phone: (215)770-2842
  5. #            AT&T Bell Laboratories   E-mail: aluxpo!mmc@att.com
  6. #
  7. #     SCCS:  @(#)testlib.tcl    1.1 (7/15/93)
  8. # ----------------------------------------------------------------------
  9. #            Copyright (c) 1993  AT&T  All Rights Reserved
  10. # ======================================================================
  11.  
  12. # ----------------------------------------------------------------------
  13. #  USAGE:  test <test-desc> <test-cmd> <check>
  14. #
  15. #  Executes the given test, the evaluates the <check> condition to
  16. #  see if the test passed.  The result from the <test-cmd> is kept
  17. #  in the variable $result.  If this condition evaluates non-zero,
  18. #  the test has passed.  Otherwise, the test has failed.  A variety
  19. #  if checking routines (test_cmp_*) are provided below to make
  20. #  the check condition easier to write.
  21. # ----------------------------------------------------------------------
  22. proc test {desc cmd check} {
  23.     set result [uplevel $cmd]
  24.  
  25.     if {![expr $check]} {
  26.         puts stdout "-------------------------------------------------------"
  27.         puts stdout ">>>> FAILED TEST <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
  28.         puts stdout "-------------------------------------------------------"
  29.         set lines [split $desc "\n"]
  30.         foreach i $lines {
  31.             puts stdout $i
  32.         }
  33.         puts stdout "======================================================="
  34.         set lines [split $cmd "\n"]
  35.         set label TEST
  36.         foreach i $lines {
  37.             puts stdout "   $label | $i"
  38.             set label "    "
  39.         }
  40.         puts stdout "-------------------------------------------------------"
  41.         set lines [split $check "\n"]
  42.         set label CHECK
  43.         foreach i $lines {
  44.             if {$i != ""} {
  45.                 puts stdout "  $label | $i"
  46.                 set label "     "
  47.             }
  48.         }
  49.         puts stdout "-------------------------------------------------------"
  50.         set lines [split $result "\n"]
  51.         set label RESULT
  52.         foreach i $lines {
  53.             if {$i != ""} {
  54.                 puts stdout " $label | \$result => $i"
  55.                 set label "      "
  56.             }
  57.         }
  58.         puts stdout "======================================================="
  59.         error "tests aborted"
  60.     }
  61. }
  62.  
  63. # ----------------------------------------------------------------------
  64. #  USAGE:  test_cmp_nums <num1> <num2>
  65. #
  66. #  Compares two numbers to see if they are "equal."  Numbers are
  67. #  "equal" if they have an absolute value greater than 1.0e-6 and they
  68. #  have at least 5 significant figures.  Returns 1/0 for true/false.
  69. # ----------------------------------------------------------------------
  70. proc test_cmp_nums {num1 num2} {
  71.     global TEST_ABS_TOL TEST_REL_TOL
  72.  
  73.     if {[expr abs($num1)] > $TEST_ABS_TOL &&
  74.         [expr abs($num2)] > $TEST_ABS_TOL} {
  75.         set avg [expr 0.5*($num1+$num2)]
  76.         set diff [expr abs(($num1-$num2)/$avg)]
  77.  
  78.         if {$diff > $TEST_REL_TOL} {
  79.             return 0
  80.         }
  81.     }
  82.     return 1
  83. }
  84.  
  85. # ----------------------------------------------------------------------
  86. #  USAGE:  test_cmp_vectors <list1> <list2>
  87. #
  88. #  Compares two lists of numbers to see if they are "equal."  Vectors
  89. #  are "equal" if elements are "equal" in the numeric sense.
  90. #  Returns 1/0 for true/false.
  91. # ----------------------------------------------------------------------
  92. proc test_cmp_vectors {list1 list2} {
  93.     if {[llength $list1] != [llength $list2]} {
  94.         return 0
  95.     }
  96.     for {set i 0} {$i < [llength $list1]} {incr i} {
  97.         set n1 [lindex $list1 $i]
  98.         set n2 [lindex $list2 $i]
  99.  
  100.         if {![test_cmp_nums $n1 $n2]} {
  101.             return 0
  102.         }
  103.     }
  104.     return 1
  105. }
  106.  
  107. # ----------------------------------------------------------------------
  108. #  USAGE:  test_cmp_lists <list1> <list2>
  109. #
  110. #  Compares two lists to see if they are "equal."  Lists are "equal"
  111. #  if they contain exactly the same elements, but perhaps in a
  112. #  different order.  Returns 1/0 for true/false.
  113. # ----------------------------------------------------------------------
  114. proc test_cmp_lists {list1 list2} {
  115.     if {[llength $list1] != [llength $list2]} {
  116.         return 0
  117.     }
  118.     foreach elem $list1 {
  119.         set i [lsearch $list2 $elem]
  120.         if {$i >= 0} {
  121.             set list2 [lreplace $list2 $i $i]
  122.         } else {
  123.             return 0
  124.         }
  125.     }
  126.     return 1
  127. }
  128.